
#lang scheme/base

(require scheme/list)
(require scheme/function)
(require "quiz.rkt")

(define debug-print #f)

(define (doctor patients)
  
  (cond ((> patients 0)
         (printf "Ok, I am doctor Who! What is your name? \n") 
         (print '**)
         (let ((user-response (read))) 
           (cond ((null? user-response) 
                  (printf "I need someone to talk to!\n")
                  (doctor patients))
                 ((equal? user-response '(closing time)) 
                  (printf "I have to go home!\n")) 
                 (else (visit-doctor (car user-response)) 
                       (doctor (- patients 1)))))) 
        (else (printf "It is time to go home!\n"))))

(define (visit-doctor name)
  
  ;------------------------------------------------------------------------------
  ;return ((handler, e.g (1 pred? proc)) (answer) (own-history) (glob-history-1) (glob-history-2) ...)
  (define (makeanswer handlers history) ;handlers format( (10 pred proc) )    
    
    (define (roulette-wheel-selection handlers weight) ;weighted random selection
      
      (define (select rndnumber templist)
        (let ((rndnumber (- rndnumber (weight (car templist)))))
          (cond ((<= rndnumber 0) (car templist))
                (else (select rndnumber (cdr templist))))))
      
      (if (null? handlers) '() (select (random (+ 1 (foldr + 0 (map weight handlers)))) handlers)))
    
    (define (extmin handlers weight) ;найти с минимальным весом
      
      (define (findmin list minitem)
        (cond ((null? list) minitem)
              ((< (weight (car list)) (weight minitem)) (findmin (cdr list) (car list)))
              (else (findmin (cdr list) minitem))))
      
      (if (null? handlers) '() (findmin handlers (car handlers))))
    
    (define (filter-pos-handlers) (filter (lambda(handler) (and (> (car handler) 0) ((second handler) history (fourth handler)))) handlers))
    (define (filter-neg-handlers) (filter (lambda(handler) (and (< (car handler) 0) ((second handler) history (fourth handler)))) handlers))
    
    (let ((neg-handlers (filter-neg-handlers)) (pos-handlers (filter-pos-handlers)))
      (cond ((not (null? neg-handlers)) 
             (let ((next-neg-handler (extmin neg-handlers car)))
               (cons next-neg-handler ((third next-neg-handler) history (fourth next-neg-handler)))))
            ((null? pos-handlers) (cons '() history))
            (else 
             (let ((next-pos-handler (roulette-wheel-selection pos-handlers car)))
               (cons next-pos-handler ((third next-pos-handler) history (fourth next-pos-handler))))))))
  
  ;------------------------------------------------------------------------------
  
  (define (init-handlers) 
    (list (list 1 (const #t) hedge-reply '())
          (list 5 oftenoccur? ofoc-reply '())
          (list 100 smart? smart-reply '())
          (list 100 qualifier? qualifier-reply '())
          (list 5 short? short-reply '())
          (list 5 flashback? flashback-reply '())
          (list 5 repeat? repeat-reply '())
          (list -1 yes? yes-reply '())
          (list -1 no? no-reply '())
          (list -2 becouse? becouse-reply '())
          (list -3 question? counter-question '())
          (list -4 empty-response? empty-reply '())
          (list -5 quiz? quiz-reply '())))
  
  ;------------------------------------------------------------------------------
  (define (doctor-driver-loop name history handlers)
    
    ;debug print
    (cond (debug-print (newline) (printf "history: ") (print history)))
    
    (newline)
    (print '**)
    (let ((user-response (read)))       
      (cond ((equal? user-response '(goodbye))
             (printf "Goodbye, ~a!\n" name)
             (printf "See you next week!\n\n"))
            (else (let ((answer (makeanswer handlers (cons user-response history))))        
                    (cond (debug-print (print 'answer:) (print answer) (newline))) ;debug print
                    (cond ((null? (car answer)) 
                           (print '(I do not know what to say to you!))
                           (doctor-driver-loop name (cdr answer) handlers))
                          (else 
                           (let ((handler (car answer)))
                             (print (second answer))
                             (doctor-driver-loop name (cdddr answer) (append (filter (lambda(next) (not (equal? handler next))) handlers) 
                                                                             (list (list (first handler) (second handler) (third handler) (third answer)))))))))))))
  ;------------------------------------------------------------------------------
  
  (printf "Hello, ~a!\n" name)
  (print '(what seems to be the trouble?))
  (doctor-driver-loop name '() (init-handlers)))

(define (pick-random list)
  (list-ref list (random (length list)))) 

(define (empty-response? history own-history) ;пустой ответ?
  (null? (car history))) 

(define (empty-reply history own-history) ;ответить на пустой ответ
  (define (answer) (pick-random '((tell me something)
                                  (we need to talk))))
  (append (list (answer) own-history) (cdr history)))

(define (question? history own-history) ;нам задали вопрос?
  (or (member (car history) '(do did does is are was can could may will would why where when what how which who))
      (member '? (car history))))

(define (counter-question history own-history) ;ответить на вопрос контр-вопросом
  (define (answer) (pick-random '((why do you ask ?)
                                  (does that question interest you ?)
                                  (what is it you really wanted to know ?)
                                  (are such questions much on your mind ?)
                                  (what answer would please you most ?)
                                  (what do you think ?)
                                  (what comes to mind when you ask that ?)
                                  (have you asked such questions before ?)
                                  (have you asked anyone else ?))))
  (append (list (answer) own-history) (cdr history)))

(define (flashback? history own-history) (not (null? (cdr history)))) ;если история ответов не пустая, можно выдать старый ответ.

(define (flashback-reply history own-history) ;приставки для "старых" ответов
  (define (answer) (append (pick-random '((earlier you said that)
                                          (as you said before)
                                          (it has been noted previously that)
                                          (why did you say that))) (change-person (pick-random (cdr history)))))
  (append (list (answer) own-history) history))

(define (becouse? history own-history) ;есть в ответе "потому что"?
  (member 'becouse (car history)))

(define (becouse-reply history own-history) ;переспросим почему?
  (define (answer) (pick-random '((do not any other reasons cbome to mind ?)
                                  (is that the real reason ?)
                                  (what other reasons might there be ?)))) 
  (append (list (answer) own-history) history))

(define (yes? history own-history) ;утвердительный ответ?
  (and (not (null? (car history))) (equal? (caar history) 'yes)))

(define (yes-reply history own-history) ;похвалим за позитивность
  (define (answer) (pick-random '((you seem to be quite positive))))
  (append (list (answer) own-history) (cdr history)))

(define (no? history own-history) ;отрицательный ответ?
  (and (not (null? (car history))) (equal? (caar history) 'no)))

(define (no-reply history own-history) ;пожурим за отрицательный ответ
  (define (answer) (pick-random '((are you sure ?)
                                  (are you saying no just to be negative ?)
                                  (why not ?))))
  (append (list (answer) own-history) (cdr history)))

(define (short? history own-history) ;короткий ответ?
  (< (length (car history)) 3))

(define (short-reply history own-history) ;просим рассказать подробнее
  (define (answer) (pick-random '((that is not much of an answer)
                                  (could you say more ?)
                                  (сan you expand on that ?))))
  (append (list (answer) own-history) history))

(define (repeat? history own-history) ;повторяется?
  (member (car history) (cdr history))) 

(define (repeat-reply history own-history) ;просим не повторяться 
  (define (answer) (pick-random '((please do not repeat yourself !)
                                  (do you always have to repeat yourself ?)
                                  (do you expect a different answer by repeating yourself ?))))
  (append (list (answer) own-history) history))

(define (qualifier? history own-history) ;если ответ не пустой можем повторить то же самое от своего лица
  (not (null? (car history)))) 

(define (qualifier-reply history own-history) ;ответ от своего лица
  (define (answer) (append (pick-random '((you seem to think) 
                                          (you feel that) 
                                          (why do you believe) 
                                          (why do you say)
                                          (in my opinion)
                                          (the point is that)
                                          (i tend to think that)
                                          (do you really mean to say that)
                                          (can i conclude from this that)
                                          (would it be correct to say that)
                                          (does this mean that)
                                          (if i understand you correctly you mean)
                                          (you should realize that)
                                          (there is no doubt that))) (change-person (car history))))
  (append (list (answer) own-history) history))

(define (hedge-reply history own-history) ;ответим что-нибудь
  (define (answer) (pick-random '((please go on)
                                  (many people have the same sorts of feelings) 
                                  (many of my patients have told me the same thing) 
                                  (please continue)
                                  (please tell me more about it)
                                  (please go into more details)
                                  (pray go on with your narrative)
                                  (are you afraid of talking about it ?)
                                  (what does that suggest to you ?)
                                  (i am not sure i understand you fully)
                                  (i did not get that)
                                  (i am not sure i got your point)
                                  (what do you feel about it ?)
                                  (do you feel strongly about discussing such things ?)
                                  (if you had three wishes, what would they be ?)
                                  (how do you feel now ?)
                                  (how much time do you spend thinking about it ?)
                                  (what kinds of things make you nervous ?)
                                  (what were you afraid of as a child ?)
                                  (what is your biggest fear ?)
                                  (what are you trying to say ?)
                                  (please calm down)
                                  ;(The Turing Test is Too Hard)
                                  (i am sorry for the pain you are going through, i know it hurts a lot)))) 
  (append (list (answer) own-history) history))

(define (change-person phrase)
  
  (define (doctor-replace replacement-pairs list)   
    
    (define (get-replacement replacement-pairs word)
      (cond ((null? replacement-pairs) '())
            ((equal? (caar replacement-pairs) word) (car replacement-pairs)) 
            (else (get-replacement (cdr replacement-pairs) word))))
    
    (map (lambda(word)
           (let ((replacement (get-replacement replacement-pairs word))) 
             (cond ((null? replacement) word) 
                   (else (cadr replacement))))) 
         list))
  
  (doctor-replace '((i you) (me you) (am are) (my your) (are am) (here there)
                            (you i) (your my) (myself yourself) (yourself myself) (ourselves yourselves)
                            (mine yours) (yours mine) (our your) (ours yours) (we you)) phrase))

(define (patterns) '(((everyone someone everybody somebody noone nobody) 
                      (are you talking about me in particular ?)
                      (who, for example ?) (who do you think you are talking about ?))
                     ((computer machine) 
                      (what is it about machines that worries you ?)
                      (what do you think about machines ?))
                     ((handball football volleyball cricket baseball tennis badminton) 
                      (do you like to play * ?))
                     ((depressed suicide) 
                      (when you feel depressed, go out for ice cream) (depression is a disease that can be treated)) 
                     ((mother father parents sister brother son daughter wife husband family) 
                      (tell me more about your *) (what do you think about your * ?) (do you love your * ?))))

(define (filter-patterns patterns user-response)
  
  (define (sublist list1 list2)
    (filter (lambda(item) (memq item list1)) list2))
  
  (cond ((null? patterns) '())
        (else (let ((templist (sublist (caar patterns) user-response))) 
                (cond ((null? templist) (filter-patterns (cdr patterns) user-response))
                      (else (cons (cons templist (cdar patterns)) (filter-patterns (cdr patterns) user-response))))))))

(define (make-answer patterns)    
  (cond ((null? patterns) '()) 
        (else (let ((pattern (pick-random patterns)))
                (let ((pair (pick-random (car pattern))))
                  (map (lambda(word) (if (equal? word '*) pair word)) (pick-random (cdr pattern))))))))


(define (smart? history own-history)  ;проверим, есть ли подходящая тема по ключевому слову
  (not (null? (filter-patterns (patterns) (car history)))))

(define (smart-reply history own-history) ;выдать ответ по ключевому слову
  (append (list (make-answer (filter-patterns (patterns) (car history))) own-history) history)) 

(define (oftenoccur history)
  
  ;http://www.ranks.nl/stopwords
  (define (stopwords)
    '(I a about an are as at be by com for from how in 
        is it of on or that the this to was what when where
        who will with the))
  
  (define (countwords words)
    (cond ((null? words) '())
          (else (let ((count (length (filter (lambda (item) (equal? item (car words))) words))))
                  (cond ((< 5 count) (cons (list count (car words)) 
                                           (countwords (filter (lambda (item) (not (equal? item (car words)))) words))))
                        (else (countwords (filter (lambda (item) (not (equal? item (car words)))) words))))))))
  
  (countwords (filter (lambda (item) (not (member item (stopwords)))) (flatten history))))

(define (oftenoccur? history own-history) ;есть ли часто встречающиеся слова?
  (not (null? (oftenoccur history)))) 

(define (ofoc-reply history own-history) ;почему вы так часто говорите о ?
  (define (answer) (append (pick-random '((why are you concentrating on)
                                          (do you want to keep talking about)
                                          (why are you always talking about)
                                          (how much time do you spend thinking about))) 
                           (list (cadr (pick-random (oftenoccur history))) '?)))
  (append (list (answer) own-history) history))

(define (find-sublist list sub)
  (define (sublist? list sub)
    (or (null? sub)
        (and (not (null? list))
             (equal? (car sub) (car list))
             (sublist? (cdr list) (cdr sub)))))
  
  (let walking ((list list) (index 1) (indices '()))
    (if (null? list)
        (reverse indices)
        (walking (cdr list)
                 (+ 1 index)
                 (if (sublist? list sub)
                     (cons index indices)
                     indices)))))

(doctor 1)